Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/CURVETXT.FRM

Text File | 1996-04-19 | 10KB | 291 lines

VERSION 4.00
Begin VB.Form CurveTxtForm
   AutoRedraw      =   -1  'True
   BackColor       =   &H00FFFFFF&
   Caption         =   "CurveTxt"
   ClientHeight    =   5325
   ClientLeft      =   1815
   ClientTop       =   1155
   ClientWidth     =   5715
   Height          =   6015
   Left            =   1755
   LinkTopic       =   "Form1"
   ScaleHeight     =   266.25
   ScaleMode       =   2  'Point
   ScaleWidth      =   285.75
   Top             =   525
   Width           =   5835
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "CurveTxtForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Const PI = 3.14159
Const PI_OVER_2 = PI / 2

' ***********************************************
' Draw a text string along a path specified by a
' series of points (ptx(i), pty(i)). The text is
' placed above the curve if parameter above is
' true. The font uses the given font metrics.
' ***********************************************
Sub CurveText(txt As String, numpts As Integer, ptx() As Single, pty() As Single, above As Boolean, nHeight As Long, nWidth As Long, fnWeight As Long, fbItalic As Long, fbUnderline As Long, fbStrikeOut As Long, fbCharSet As Long, fbOutputPrecision As Long, fbClipPrecision As Long, fbQuality As Long, fbPitchAndFamily As Long, lpszFace As String)
Dim newfont As Long
Dim oldfont As Long
Dim theta As Single
Dim escapement As Long
Dim ch As String
Dim chnum As Integer
Dim needed As Single
Dim avail As Single
Dim newavail As Single
Dim pt As Integer
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single
Dim dx As Single
Dim dy As Single

    avail = 0
    chnum = 1

    x1 = ptx(1)
    y1 = pty(1)
    For pt = 2 To numpts
        ' See how long the new segment is.
        x2 = ptx(pt)
        y2 = pty(pt)
        dx = x2 - x1
        dy = y2 - y1
        newavail = Sqr(dx * dx + dy * dy)
        avail = avail + newavail

        ' Create a font along the segment.
        If dx > -0.1 And dx < 0.1 Then
            If dy > 0 Then
                theta = PI_OVER_2
            Else
                theta = -PI_OVER_2
            End If
        Else
            theta = Atn(dy / dx)
            If dx < 0 Then theta = theta - PI
        End If
        escapement = -theta * 180# / PI * 10#
        If escapement = 0 Then escapement = 3600
        newfont = CreateFont(nHeight, nWidth, escapement, 0, fnWeight, fbItalic, fbUnderline, fbStrikeOut, fbCharSet, fbOutputPrecision, fbClipPrecision, fbQuality, fbPitchAndFamily, lpszFace)
        oldfont = SelectObject(hdc, newfont)

        ' Output characters until no more fit.
        Do
            ' See how big the next character is.
            ' (Add a little to prevent characters
            ' from becoming too close together.)
            ch = Mid$(txt, chnum, 1)
            needed = TextWidth(ch) * 1.2

            ' If it's too big, get another segment.
            If needed > avail Then Exit Do

            ' See where the character belongs
            ' along the segment.
            CurrentX = x2 - dx / newavail * avail
            CurrentY = y2 - dy / newavail * avail
            If above Then
                ' Place text above the segment.
                CurrentX = CurrentX + dy * nHeight / newavail
                CurrentY = CurrentY - dx * nHeight / newavail
            End If

            ' Display the character.
            Print ch;

            ' Move on to the next character.
            avail = avail - needed
            chnum = chnum + 1
            If chnum > Len(txt) Then Exit Do
        Loop

        ' Free the font.
        newfont = SelectObject(hdc, oldfont)
        If DeleteObject(newfont) = 0 Then
            Beep
            MsgBox "Error deleting font object.", vbExclamation
        End If

        If chnum > Len(txt) Then Exit For
        x1 = x2
        y1 = y2
    Next pt
End Sub

' ***********************************************
' Draw a text string along a circle centered at
' (X, Y) with radius R, centered around the angle
' theta in radians measured counterclockwise from
' the X axis.
' ***********************************************
Sub CircleText(txt As String, X As Single, Y As Single, R As Single, ByVal theta As Single, inside As Boolean, nHeight As Long, nWidth As Long, fnWeight As Long, fbItalic As Long, fbUnderline As Long, fbStrikeOut As Long, fbCharSet As Long, fbOutputPrecision As Long, fbClipPrecision As Long, fbQuality As Long, fbPitchAndFamily As Long, lpszFace As String)
Dim newfont As Long
Dim oldfont As Long
Dim escapement As Long
Dim ch As String
Dim i As Integer
Dim wid As Single
Dim R2 As Single

    If inside Then
        R2 = R
    Else
        R2 = R + 0.8 * nHeight
    End If

    ' See how long the string is.
    newfont = CreateFont(nHeight, nWidth, 3600, 0, fnWeight, fbItalic, fbUnderline, fbStrikeOut, fbCharSet, fbOutputPrecision, fbClipPrecision, fbQuality, fbPitchAndFamily, lpszFace)
    oldfont = SelectObject(hdc, newfont)
    wid = TextWidth(txt)
    newfont = SelectObject(hdc, oldfont)
    If DeleteObject(newfont) = 0 Then
        Beep
        MsgBox "Error deleting font object.", vbExclamation
    End If

    ' The minus sign is needed because Sin and Cos
    ' measure angles clockwise while the input
    ' parameter theta is measured counterclockwise.
    theta = -(theta + wid / R / 2)

    ' Start printing letters.
    For i = 1 To Len(txt)
        CurrentX = X + R2 * Cos(theta)
        CurrentY = Y + R2 * Sin(theta)

        escapement = (-PI_OVER_2 - theta) * 180# / PI * 10#
        If escapement = 0 Then escapement = 3600
        newfont = CreateFont(nHeight, nWidth, escapement, 0, fnWeight, fbItalic, fbUnderline, fbStrikeOut, fbCharSet, fbOutputPrecision, fbClipPrecision, fbQuality, fbPitchAndFamily, lpszFace)
        oldfont = SelectObject(hdc, newfont)

        ch = Mid$(txt, i, 1)
        Print ch
        theta = theta + TextWidth(ch) / R

        newfont = SelectObject(hdc, oldfont)
        If DeleteObject(newfont) = 0 Then
            Beep
            MsgBox "Error deleting font object.", vbExclamation
        End If
    Next i
End Sub

' ************************************************
' Draw an assortment of text samples.
' ************************************************
Sub DrawTheText()
Const NUM_PTS = 22

Dim X As Single
Dim Y As Single
Dim R As Single
Dim pt As Long
Dim fnt As String
Dim ang As Single
Dim i As Integer
Dim ptx(1 To NUM_PTS) As Single
Dim pty(1 To NUM_PTS) As Single
Dim dx As Single
Dim dy As Single

    Cls
    MousePointer = vbHourglass
    DoEvents

    ' *************************
    ' * Text along a polyline *
    ' *************************
    pt = 20
    fnt = "Times New Roman"

    ' Build the points in the path.
    dx = ScaleWidth / (NUM_PTS + 1)
    For i = 1 To NUM_PTS
        ptx(i) = i * dx
        pty(i) = 10 + pt + 10 * Sin(3 * i * PI / NUM_PTS)
    Next i

    ' Display the path.
    Line (ptx(1), pty(1))-(ptx(2), pty(2))
    For i = 3 To NUM_PTS
        Line -(ptx(i), pty(i))
    Next i

    ' Place text along the path.
    CurveText "Text looks best on a fairly smooth curve.", NUM_PTS, ptx, pty, True, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt
    CurveText "Text looks best on a fairly smooth curve.", NUM_PTS, ptx, pty, False, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt

    ' *****************
    ' * Circular text *
    ' *****************
    pt = 20
    R = 90
    X = ScaleWidth / 2
    Y = R + 20 + 2 * pt
    Circle (X, Y), R

    ' Text outside the circle.
    ang = PI_OVER_2
    CircleText "Round and round the mulberry bush", X, Y, R, ang, False, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, "Times New Roman"
    ang = -PI_OVER_2
    CircleText "The programmer chased the weasel", X, Y, R, ang, False, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, "Times New Roman"

    ' Text inside the circle.
    pt = 15
    ang = 0
    CircleText "CircleText can display text", X, Y, R, ang, True, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, "Courier New"
    ang = PI
    CircleText "Inside or outside the circle", X, Y, R, ang, True, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, "Courier New"

    ' ************************
    ' * Text along a diamond *
    ' ************************
    pt = 15

    ' Build the points in the path.
    dx = 61
    dy = 61
    ptx(1) = X - dx: pty(1) = Y
    ptx(2) = X: pty(2) = Y - dy
    ptx(3) = X + dx: pty(3) = Y
    ptx(4) = X: pty(4) = Y + dy
    ptx(5) = X - dx: pty(5) = Y

    ' Display the path.
    Line (ptx(1), pty(1))-(ptx(2), pty(2))
    For i = 3 To 5
        Line -(ptx(i), pty(i))
    Next i

    ' Place text along the path.
    CurveText "Sharp corners can cause gaps or overlap when text follows a path.", 5, ptx, pty, True, pt, 0, 0, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, fnt

    MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    DrawTheText
End Sub


Private Sub mnuFileExit_Click()
    Unload Me
End Sub